Dijkstra's Algorithm/Sample VB.frm
VERSION 5.00
Begin VB.Form Mfrm
AutoRedraw = ‑1 'True
Caption = "Dijkstra's Algorithm Sample"
ClientHeight = 4995
ClientLeft = 60
ClientTop = 465
ClientWidth = 7635
LinkTopic = "Form1"
ScaleHeight = 4995
ScaleWidth = 7635
StartUpPosition = 3 'Windows‑Standard
Begin VB.CommandButton ModeOverkillCommand
Caption = "Overkill"
Height = 255
Left = 60
TabIndex = 3
Top = 840
Width = 1095
End
Begin VB.CommandButton ModeFindPathCommand
Caption = "Find Path"
Height = 255
Left = 60
TabIndex = 2
Top = 540
Width = 1095
End
Begin VB.OptionButton ModeLinkOption
Caption = "Link"
Height = 195
Left = 60
TabIndex = 1
Top = 300
Width = 1035
End
Begin VB.OptionButton ModeCreateOption
Caption = "Create"
Height = 195
Left = 60
TabIndex = 0
Top = 60
Value = ‑1 'True
Width = 1035
End
End
Attribute VB_Name = "Mfrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2002, 2004 by Louis.
'
'NOTE: this code sample has clearly defined interfaces so that the
'main code (Dijkstramod) can be copied to other projects, too.
'
'Downloaded from www.louis‑coder.com.
'Implementation of the Dijkstra‑algorithm to find the shortest path
'between two nodes within a graph.
'
'NodeStruct
Private Type NodeStruct
NodeName As String
NodeXPos As Long 'in twips, not relevant for D. calculation
NodeYPos As Long 'in twips, not relevant for D. calculation
NodeLinkNumber As Long 'how many links are in use
NodeLinkArray(1 To 128) As Long
End Type
Dim NodeStructNumber As Long 'how many nodes are used
Dim NodeStructArray(1 To 128) As NodeStruct
'other
Dim ModeLinkFirstOrSecondFlag As Boolean
Dim ModeLinkNodeIndex As Long
Private Sub Form_Load()
'on error resume next
ModeLinkFirstOrSecondFlag = True 'preset
End Sub
Private Sub ModeFindPathCommand_Click()
'on error resume next
Dim NodeLinkMatrix(1 To 128, 1 To 128) As Long
Dim NodeStartIndex As Long
Dim NodeEndIndex As Long
Dim PathLengthMin As Long
Dim PathIndexNumber As Long
Dim PathIndexArray() As Long
Dim Temp1 As Long
Dim Temp2 As Long
Dim Tempstr$
'begin
NodeStartIndex = GetNodeIndexFromNodeName(InputBox("Enter start node name:", "Dijkstra Algorithm Test", ""))
If NodeStartIndex = 0 Then Exit Sub 'verify
NodeEndIndex = GetNodeIndexFromNodeName(InputBox("Enter end node name:", "Dijkstra Algorithm Test", ""))
If NodeEndIndex = 0 Then Exit Sub 'verify
'create matrix
For Temp1 = 1 To 128
For Temp2 = 1 To 128
NodeLinkMatrix(Temp1, Temp2) = DIJKSTRA_NO_CONNECTION 'preset
Next Temp2
Next Temp1
For Temp1 = 1 To NodeStructNumber
For Temp2 = 1 To NodeStructArray(Temp1).NodeLinkNumber
NodeLinkMatrix(Temp1, NodeStructArray(Temp1).NodeLinkArray(Temp2)) = 1 'cost is always 1 in this sample
NodeLinkMatrix(NodeStructArray(Temp1).NodeLinkArray(Temp2), Temp1) = 1 'cost is always 1 in this sample
Next Temp2
Next Temp1
'find path
'
'NOTE: an item is NOT connected to itself by default.
'
Call Dijkstra_FindPath(NodeStructNumber, NodeLinkMatrix(), NodeStartIndex, NodeEndIndex, PathLengthMin, PathIndexNumber, PathIndexArray())
MsgBox "Minimal path length: " + CStr(PathLengthMin), vbOKOnly + vbInformation
For Temp1 = 1 To PathIndexNumber
Tempstr$ = Tempstr$ + NodeStructArray(PathIndexArray(Temp1)).NodeName + " "
Next Temp1
MsgBox "Walked path: " + Tempstr$, vbOKOnly + vbInformation
End Sub
Private Sub ModeOverkillCommand_Click()
'on error resume next
Dim NodeNumberMax As Long
Dim X As Single
Dim Y As Single
Dim Temp1 As Long
Dim Temp2 As Long
'preset
Randomize Timer
ModeCreateOption.Value = True
NodeStructNumber = 0 'reset
'begin
NodeNumberMax = Val(InputBox("Enter overkill intensity (1‑128)", "Overkill Test", "32"))
If NodeNumberMax < 1 Then NodeNumberMax = 1 'verify
If NodeNumberMax > 128 Then NodeNumberMax = 128 'verify
For Temp1 = 1 To NodeNumberMax
X = Int((Mfrm.ScaleWidth ‑ 0 + 1) * Rnd(1) + 0)
Y = Int((Mfrm.ScaleHeight ‑ 0 + 1) * Rnd(1) + 0)
Call Form_MouseUp(vbLeftButton, 0, X, Y)
Next Temp1
For Temp1 = 1 To NodeNumberMax
NodeStructArray(Temp1).NodeLinkNumber = 0 'reset
For Temp2 = 1 To NodeNumberMax
If (Not (Temp1 = Temp2)) And (Rnd(1) < 0.3333333!) Then
NodeStructArray(Temp1).NodeLinkNumber = NodeStructArray(Temp1).NodeLinkNumber + 1
NodeStructArray(Temp1).NodeLinkArray(NodeStructArray(Temp1).NodeLinkNumber) = Temp2
End If
Next Temp2
Next Temp1
Call Redraw
End Sub
'***DRAWING***
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'on error resume next
If ModeCreateOption.Value = True Then
If Not (NodeStructNumber = 128) Then
NodeStructNumber = NodeStructNumber + 1
NodeStructArray(NodeStructNumber).NodeXPos = X
NodeStructArray(NodeStructNumber).NodeYPos = Y
NodeStructArray(NodeStructNumber).NodeName = CStr(NodeStructNumber)
Call Redraw
Else
MsgBox "Sorry, you cannot create more than 128 nodes !", vbOKOnly + vbExclamation
Exit Sub
End If
End If
If ModeLinkOption.Value = True Then
If ModeLinkFirstOrSecondFlag = True Then
ModeLinkFirstOrSecondFlag = False
ModeLinkNodeIndex = GetNodeIndexFromMousePos(X, Y)
Else
ModeLinkFirstOrSecondFlag = True 'reset
If (Not (ModeLinkNodeIndex = 0)) And (Not (GetNodeIndexFromMousePos(X, Y)) = 0) Then
If Not (NodeStructArray(ModeLinkNodeIndex).NodeLinkNumber = 128) Then
NodeStructArray(ModeLinkNodeIndex).NodeLinkNumber = NodeStructArray(ModeLinkNodeIndex).NodeLinkNumber + 1
NodeStructArray(ModeLinkNodeIndex).NodeLinkArray(NodeStructArray(ModeLinkNodeIndex).NodeLinkNumber) = GetNodeIndexFromMousePos(X, Y)
Call Redraw
Else
MsgBox "Too much links (max. 128) !", vbOKOnly + vbExclamation
Exit Sub
End If
End If
End If
End If
Exit Sub
End Sub
Private Function GetNodeIndexFromMousePos(ByVal X As Long, ByVal Y As Long)
'on error resume next
Dim Temp As Long
'begin
'
'a�=b�+c�
'a=sqr(b�+c�)
'
For Temp = 1 To NodeStructNumber
If Abs(Sqr((X ‑ NodeStructArray(Temp).NodeXPos) ^ 2 + (Y ‑ NodeStructArray(Temp).NodeYPos) ^ 2)) <= 5 * Screen.TwipsPerPixelX Then
GetNodeIndexFromMousePos = Temp
Exit Function
End If
Next Temp
GetNodeIndexFromMousePos = 0
Exit Function
End Function
Private Function GetNodeIndexFromNodeName(ByVal NodeName As String)
'on error resume next
Dim Temp As Long
'begin
For Temp = 1 To NodeStructNumber
If NodeStructArray(Temp).NodeName = NodeName Then
GetNodeIndexFromNodeName = Temp
Exit Function
End If
Next Temp
GetNodeIndexFromNodeName = 0
Exit Function
End Function
Private Sub Redraw()
'on error resume next
Dim Temp1 As Long
Dim Temp2 As Long
'preset
Me.Cls
Me.ForeColor = 0
Me.FillStyle = vbSolid
'begin
For Temp1 = 1 To NodeStructNumber
For Temp2 = 1 To NodeStructArray(Temp1).NodeLinkNumber
Me.Line ( _
NodeStructArray(Temp1).NodeXPos, NodeStructArray(Temp1).NodeYPos)‑( _
NodeStructArray(NodeStructArray(Temp1).NodeLinkArray(Temp2)).NodeXPos, NodeStructArray(NodeStructArray(Temp1).NodeLinkArray(Temp2)).NodeYPos), 0
Next Temp2
Next Temp1
For Temp1 = 1 To NodeStructNumber
Me.ForeColor = 0
Me.Circle (NodeStructArray(Temp1).NodeXPos, NodeStructArray(Temp1).NodeYPos), 5 * Screen.TwipsPerPixelX
Me.ForeColor = RGB(255, 255, 255)
Me.CurrentX = NodeStructArray(Temp1).NodeXPos + 10 * Screen.TwipsPerPixelX
Me.CurrentY = NodeStructArray(Temp1).NodeYPos
Me.Print NodeStructArray(Temp1).NodeName
Next Temp1
End Sub
'***END OF DRAWING***
[END OF FILE]